home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / menus.tcl < prev    next >
Encoding:
Text File  |  2001-01-24  |  31.9 KB  |  1,086 lines
  1. #  AlphaTcl - core Tcl engine
  2. # Menu creation procs
  3.     
  4. namespace eval menu {}
  5. namespace eval global {}
  6. namespace eval file {}
  7.  
  8. proc menu::buildBasic {} {
  9.     global winMenu
  10.     # These are built on the fly
  11.     Menu -n File -p menu::generalProc {}
  12.     Menu -n Edit -p menu::generalProc {}
  13.     Menu -n Text -p menu::generalProc {}
  14.     Menu -n Search {}
  15.     Menu -n Utils {}
  16.     Menu -n Config {}
  17.     Menu -n $winMenu {}
  18.     
  19.     insertMenu "File"
  20.     insertMenu "Edit"
  21.     insertMenu "Text"
  22.     insertMenu "Search"
  23.     insertMenu "Utils"
  24.     insertMenu "Config"
  25.     insertMenu $winMenu
  26.     
  27.     help::buildMenu
  28. }
  29.  
  30. proc menu::buildwinMenu {} {
  31.     global winMenu winNameToNum
  32.     set ma {
  33.     "//<Szoom"
  34.     "//<S<I<OdefaultSize"
  35.     "<S/;chooseAWindow"
  36.     "/I<Biconify"
  37.     {Menu -n arrange -p menu::winTileProc {
  38.         "/Jvertically^1"
  39.         "/J<O<Ihorizontally^2"
  40.         "/J<B<OunequalVert^6"
  41.         "/J<B<I<OunequalHor^5"
  42.         "(-"
  43.         {Menu -n other {
  44.         {bufferOtherWindow}
  45.         {iconify}
  46.         {nextWin}
  47.         {nextWindow}
  48.         {prevWindow}
  49.         {shrinkFull}
  50.         {shrinkHigh}
  51.         {shrinkLeft}
  52.         {shrinkLow}
  53.         {shrinkRight}
  54.         {defaultSize}
  55.         {swapWithNext}
  56.         {zoom}
  57.         }}}
  58.     }
  59.     "(-"
  60.     "/msplitWindow"
  61.     "/otoggleScrollbar"
  62.     "(-"
  63.     }
  64.     # We may be reloading, so add whatever windows we have
  65.     if {[info exists winNameToNum]} {
  66.     set nms [array names winNameToNum]
  67.     foreach name $nms {
  68.         set item [file tail $name]
  69.         set num $winNameToNum($name)
  70.         if {$num < 10}     {
  71.         lappend ma /$num${item}
  72.         } else {
  73.         lappend ma ${item}
  74.         }
  75.     }
  76.     }
  77.     return [list "build" $ma menu::winProc "" $winMenu]
  78. }
  79.  
  80. proc global::listAllBindings {} {
  81.     new -n {* All Key Bindings *} -m Tcl -info [bindingList]
  82. }
  83.  
  84. proc global::listGlobalBindings {} {
  85.     set text ""
  86.     set tmp [mode::listAll]
  87.     foreach b [split [bindingList] "\r"] {
  88.     set lst [lindex [split $b  " "] end]
  89.     if {[lsearch $tmp $lst] < 0} {
  90.         append text "$b\r"
  91.     }
  92.     }
  93.     new -n {* Global Key Bindings *} -m Tcl -info $text
  94. }
  95.  
  96. ## 
  97.  #  ------------------------------------------------------------------------
  98.  # 
  99.  # "global::listPackages" --
  100.  # 
  101.  # Creates the file "Packages", saves it in the Help folder (over-writing
  102.  # if necessary.)  Includes hyperlinks to any available package help. 
  103.  # ------------------------------------------------------------------------
  104.  ##
  105. proc global::listPackages {} {
  106.     global HOME index::feature timeStampStyle index::maintainer
  107.     cache::readContents index::maintainer
  108.     foreach i [array names index::maintainer] {
  109.     set j [lindex [set index::maintainer($i)] 1]
  110.     set au($i) "[lindex $j 0], [lindex $j 1]"
  111.     }
  112.     foreach p [lsort -ignore [array names index::feature]] {
  113.     set v [alpha::package versions $p]
  114.     if {[lindex $v 0] == "mode"} {
  115.         set v "for [lindex $v 1] mode"
  116.     }
  117.     switch -- [lindex [set index::feature($p)] 2] {
  118.         "1" {
  119.         if {[alpha::package versions $p] == $v} {
  120.             # Usual Menus (tm1)
  121.             append tm1 "\r[format {  %-30s %-10s } \
  122.               [concat package: $p] $v]"
  123.             if {[info exists au($p)]} { append tm1 $au($p) }
  124.         } else {
  125.             # Other possible menus (tm2)
  126.             append tm2 "\r[format {  %-30s %-10s } \
  127.               [concat package: $p] $v]"
  128.             if {[info exists au($p)]} { append tm2 $au($p) }
  129.         }
  130.         }
  131.         "0" {
  132.         # Features (tp1), enabled through "Preferences -> Features"
  133.         append tp1 "\r[format {%s %-30s %-10s } \
  134.           [package::active $p {• { }}] [concat package: $p] $v]"
  135.         if {[info exists au($p)]} { append tp1 $au($p) }
  136.         }
  137.         "2" {
  138.         # Features (tp2), enabled as flag preferences
  139.         append tp2 "\r[format {%s %-42s %-10s } \
  140.           [package::active $p {• { }}] [concat package: $p] $v]"
  141.         if {[info exists au($p)]} { append tp2 $au($p) }
  142.         }
  143.         "-1" {
  144.         # Auto-loading features (ta)
  145.         append ta "\r[format {  %-30s %-10s  } \
  146.           [concat package: $p] $v]"
  147.         if {[info exists au($p)]} { append ta $au($p) }
  148.         }
  149.     }
  150.     }
  151.     # Is the current window "Packages" ?  If so, close it, so that it can
  152.     # be over-written.
  153.     if {[win::CurrentTail] == "Packages"} {
  154.     menu::fileProc "File" "close"
  155.     }
  156.     # Create a new file, insert title information at the top.
  157.     new -n {* Installed Packages *} -m Text
  158.     set created [mtime [now] $timeStampStyle]
  159.     set alphaV  [alpha::package versions Alpha]
  160.     set alphatclV  [alpha::package versions AlphaTcl]
  161.     append t "\rCurrently installed packages, "
  162.     append t "Alpha v $alphaV, AlphaTcl $alphatclV\r"
  163.     append t "as of $created\r\r"
  164.     append t "\rTo update this file, use the "
  165.     append t "\"Config -> List Packages\" menu item.\r\r"
  166.     append t "columns are: name, version, and maintainer\r"
  167.     insertText "$t \r" ; set t ""
  168.     # Modes
  169.     append t "\r\t  \tModes:\r\r"
  170.     append t "\rSee also \"Mode Examples Help\" for example syntax files.\r\r"
  171.     foreach p [lsort -ignore [alpha::package names -mode]] {
  172.     # put version numbers back
  173.     set v [alpha::package versions $p]
  174.     append t "\r[format {  %-16s %-8s  } [concat package: $p] $v]"
  175.     if {[info exists au($p)]} {append t $au($p)}
  176.     }
  177.     insertText "$t \r" ; set t ""
  178.     #     Mode Specific Completion Tutorials
  179.     append t "\r\r\t  \t \tMode Specific Completion Tutorials:\r\r"
  180.     set td [glob -dir [file join $HOME Tcl Completions] *Tutorial*]
  181.     foreach tFile $td {
  182.     append t "\r    \"[file tail $tFile]\""
  183.     }
  184.     insertText "$t \r" ; set t ""
  185.     # Menus
  186.     append t "\r\r\t  \tMenus:\r\r"
  187.     #     Usual Menus
  188.     append t "\r\"Usual menus\" are designed to be used globally.\r\r"
  189.     if {[info exists tm1]} {append t "$tm1 \r" ; unset tm1}
  190.     #     Other Possible Menus
  191.     append t "\r\r\"Other possible menus\" are designed for specific modes.\r\r"
  192.     if {[info exists tm2]} {append t  $tm2 ; unset tm2}
  193.     insertText "$t \r" ; set t ""
  194.     # Features
  195.     append t "\r\r\t  \tFeatures:\r\r"
  196.     append t "\r  '•' = active as of $created\r"
  197.     #     Enabled via "Config -> Preferences -> Features"
  198.     append t "\r\rThese are enabled through "
  199.     append t "\"Config -> Preferences -> Features\"\r\r"
  200.     if {[info exists tp1]} {append t $tp1 ; unset tp1}
  201.     insertText "$t \r" ; set t ""
  202.     #     Enabled as flag preferences
  203.     append t "\r\rThese are enabled through "
  204.     append t "\"Interface\" or \"Input-Output\" Preferences\r\r"
  205.     if {[info exists tp2]} {append t $tp2 ; unset tp2}
  206.     insertText "$t \r"; set t ""
  207.     # Auto-loading features
  208.     append t "\r\r\t  \tAuto-loading features:\r\r"
  209.     if {[info exists ta]} {append t $ta ; unset ta}
  210.     insertText "$t \r\r" ; set t ""
  211.     # Environment
  212.     append t "\r\r\t  \tEnvironment:\r\r"
  213.     append t "\r[format {  %-30s %-10s  } \
  214.       Tcl-version [info patchlevel]]"
  215.     insertText "$t \r\r" ; set t ""
  216.     # Hyperize, color and mark file
  217.     goto [minPos]
  218.     help::hyperiseEmailAddresses
  219.     help::hyperiseUrls
  220.     help::colourHeadingsEtc
  221.     # remove the strings "package: "
  222.     global alpha::platform
  223.     if {${alpha::platform} == "alpha"} {
  224.     set pos [minPos]
  225.     while {[llength [set range [search -s -n "package: " $pos]]]} {
  226.         set pos [lindex $range 1]
  227.         replaceText [lindex $range 0] $pos ""
  228.     }
  229.     }
  230.     # Overwrite any existing "Packages" file in the Help directory
  231.     setWinInfo tabsize 4
  232.     setWinInfo state mpw
  233.     if {![file exists [file join $HOME Help Packages]]} {
  234.     close [open [file join $HOME Help Packages] w]
  235.     }
  236.     global backup
  237.     set oldBackup $backup
  238.     set backup 0
  239.     catch {saveAs -f [file join $HOME Help Packages]; save}
  240.     set backup $oldBackup
  241.     winReadOnly
  242.     catch {unset index::maintainer}
  243. }
  244.  
  245.  
  246. proc global::listFunctions {} {
  247.     global win::Modes
  248.     new -n {* Functions *} -m Tcl -info \
  249.       "===\r\tCommand-double-click on a function to see its definition\r===\r\r[join [lsort -ignore [info commands]] \r]\r"
  250. }
  251.  
  252. proc global::menus {} {global::menusAndFeatures 1}
  253. proc global::features {} {global::menusAndFeatures 2}
  254. proc global::menusAndFeatures {{mfb 0}} {
  255.     global global::features
  256.     dialog::pickMenusAndFeatures global $mfb
  257. }
  258.  
  259. proc global::insertAllMenus {} {
  260.     global global::features index::feature
  261.     foreach m ${global::features} {
  262.     if {[lindex [set index::feature($m)] 2] == 1} {
  263.         global $m
  264.         insertMenu [set $m]
  265.     }
  266.     }
  267. }
  268.  
  269. proc global::rebuildPackageIndices {} {
  270.     if {[dialog::yesno "You must quit Alpha immediately after rebuilding. \
  271.       Proceed?"]} {
  272.     alpha::rebuildPackageIndices
  273.     }
  274. }
  275.  
  276. ## 
  277.  # -------------------------------------------------------------------------
  278.  # 
  279.  # "menu::buildProc" --
  280.  # 
  281.  #  Register a procedure to be the 'build proc' for a given menu.  This
  282.  #  procedure can do one of two things:
  283.  #  
  284.  #  i) build the entire menu, including evaluating the 'menu ...' command.
  285.  #  In this case the build proc should return anything which doesn't
  286.  #  begin 'build ...'
  287.  #  
  288.  #  ii) build up part of the menu, and then allow pre-registered menu
  289.  #  insertions/replacements to take-effect.  In this case the procedure
  290.  #  should return a list of the items (listed by index):
  291.  #  
  292.  #  0: "build"
  293.  #  1: list-of-items-in-the-menu
  294.  #  2: list of other flags.  If the list doesn't contain '-p', we use
  295.  #  the standard menu::generalProc procedure.  If it does contain '-p'
  296.  #  general prmenu procedure to call when an item is selected.  
  297.  #  If nothing is given,
  298.  #  or if '-1' is given, then we don't have a procedure.  If "" is given,
  299.  #  we use the standard 'menu::generalProc' procedure.  Else we use the
  300.  #  given procedure.
  301.  #  3: list of submenus which need building.
  302.  #  4: over-ride for the name of the menu.
  303.  #  
  304.  #  You must register the build-proc before attempting to build the menu.
  305.  #  Once registered, any call of 'menu::buildSome name' will build your
  306.  #  menu.
  307.  # -------------------------------------------------------------------------
  308.  ##
  309. proc menu::buildProc {name proc} {
  310.     global menu::build_procs
  311.     set menu::build_procs($name) $proc
  312. }
  313.  
  314. ## 
  315.  # -------------------------------------------------------------------------
  316.  # 
  317.  # "menu::insert" --
  318.  # 
  319.  #  name, type, where, then list of items.  type = 'items' 'submenu'
  320.  #  
  321.  #  Add given items to a given menu, provided they are not already there.
  322.  #  Rebuild that menu if necessary.
  323.  #  
  324.  #  There are also procs 'menu::removeFrom' which does the opposite of
  325.  #  this one, and 'menu::replaceWith' which replaces a given menu item
  326.  #  with others.
  327.  # -------------------------------------------------------------------------
  328.  ##
  329. proc menu::insert {name args} {
  330.     if {[llength $args] < 3} { error "Too few args to menu::insert" }
  331.     global menu::additions alpha::noMenusYet menu::toplevels
  332.     if {[info exists menu::additions($name)]} {
  333.     set a [set menu::additions($name)]
  334.     if {[lsearch -exact $a $args] != -1} { 
  335.         return 
  336.     }
  337.     # check if it's there but in a different place; we over-ride
  338.     set dblchk [lreplace $args 1 1 "*"]
  339.     if {[set i [lsearch -glob $a $dblchk]] == -1} {
  340.         unset i
  341.     }
  342.     }
  343.     if {[info exists i]} {
  344.     set menu::additions($name) [lreplace $a $i $i $args]
  345.     } else {
  346.     lappend menu::additions($name) $args
  347.     }
  348.     if {![info exists alpha::noMenusYet]} {
  349.     # we were called after start-up; build the menu now
  350.     menu::buildSome $name
  351.     } else {
  352.     hook::register startupHook "menu::buildSome [list $name]"
  353.     }
  354. }
  355.  
  356. proc menu::uninsert {name args} {
  357.     global menu::additions alpha::noMenusYet menu::toplevels
  358.     set a [set menu::additions($name)]
  359.     if {[set idx [lsearch -exact $a $args]] == -1} { 
  360.     return 
  361.     }
  362.     set menu::additions($name) [lreplace $a $idx $idx]
  363.     if {![info exists alpha::noMenusYet]} {
  364.     # we were called after start-up; build the menu now
  365.     menu::buildSome $name
  366.     } else {
  367.     hook::register startupHook "menu::buildSome [list $name]"
  368.     }
  369. }
  370.  
  371. proc alpha::buildMainMenus {} {
  372.     # removed in 7.4
  373.     #menu::buildProc internetUpdates package::makeUpdateMenu
  374.     menu::buildProc packages menu::packagesBuild
  375.     menu::buildProc mode menu::modeBuild
  376.     menu::buildProc winMenu menu::buildwinMenu
  377.     menu::buildProc preferences menu::preferencesBuild
  378.     uplevel #0 {
  379.     source [file join $HOME Tcl SystemCode alphaMenus.tcl]
  380.     menu::buildSome "File" "Edit" "Text" "Search" "Utils" "Config" "winMenu"
  381.     }
  382. }
  383.  
  384. proc menu::register {m} {
  385.     global menu::toplevels
  386.     set menu::toplevels($m) 0
  387. }
  388.  
  389. ## 
  390.  # -------------------------------------------------------------------------
  391.  # 
  392.  # "menu::buildSome" --
  393.  # 
  394.  #  Important procedure which builds all known/registered menus from a
  395.  #  number of pieces.  It allows the inclusion of menus pieces registered
  396.  #  with the menu::insert procedure, which allows you easily to add items
  397.  #  (including dynamic and hierarchial) to any of Alpha's menus.
  398.  # 
  399.  # Results:
  400.  #  Various menus are (re)built
  401.  # 
  402.  # Side effects:
  403.  #  Items added to those menus with 'addMenuItem' will vanish.
  404.  # 
  405.  # --Version--Author------------------Changes-------------------------------
  406.  #    1.0     <vince@santafe.edu> original
  407.  #    2.0     <vince@santafe.edu> more compact, more like tk
  408.  # -------------------------------------------------------------------------
  409.  ##
  410. proc menu::buildSome {args} {
  411.     set msubs {}
  412.     foreach token $args {
  413.     eval lappend msubs [menu::buildOne $token]
  414.     }
  415.     # build sub-menus of those built
  416.     if {[llength $msubs]} {eval menu::buildSome $msubs}
  417.     foreach token $args {
  418.     hook::callAll menuBuild $token
  419.     }
  420. }
  421.  
  422. proc menu::buildOne {args} {
  423.     global menu::additions menu::build_procs alpha::noMenusYet \
  424.       menu::items
  425.     set token [lindex $args 0] ; set args [lrange $args 1 end]
  426.     if {[set len [llength $args]] > 0 || [info exists menu::build_procs($token)]} {
  427.     if {$len > 0} {
  428.         set res $args
  429.     } else {
  430.         if {[catch "[set menu::build_procs($token)]" res]} {
  431.         alpha::reportError "The menu $token had a problem starting up ; $res"
  432.         }
  433.     }
  434.     switch -- [lindex $res 0] {
  435.         "build" {
  436.         set ma [lindex $res 1]
  437.         if {[llength $res] > 2} {
  438.             set theotherflags [lrange [lindex $res 2] 1 end]
  439.             if {[lindex [lindex $res 2] 0] != -1} {
  440.             set mproc [lindex [lindex $res 2] 0]
  441.             }
  442.             if {[lindex $res 3] != ""} {
  443.             eval lappend msubs [lindex $res 3]
  444.             }
  445.             if {[lindex $res 4] != ""} { set name [lindex $res 4] }
  446.         }
  447.         } "menu" - "Menu" {
  448.         eval $res
  449.         menu::postEval $token
  450.         return ""
  451.         } default {
  452.         menu::postEval $token
  453.         return ""
  454.         }
  455.     }
  456.     } else {
  457.     set ma ""
  458.     if {[info exists menu::items($token)]} {
  459.         set ma [set menu::items($token)]
  460.         global menu::proc menu::which_subs menu::otherflags
  461.         if {[info exists menu::proc($token)]} {
  462.         set mproc [set menu::proc($token)]
  463.         }
  464.         if {[info exists menu::which_subs($token)]} {
  465.         eval lappend msubs [set menu::which_subs($token)]
  466.         }
  467.         if {[info exists menu::otherflags($token)]} {
  468.         set theotherflags [set menu::otherflags($token)]
  469.         }
  470.     }
  471.     }
  472.  
  473.     if {![info exists name]} { set name $token }
  474.     # add any registered items and make the menu contents
  475.     if {[info exists menu::additions($token)]} {
  476.     foreach ins [set menu::additions($token)] {
  477.         set where [lindex $ins 1]
  478.         set type [lindex $ins 0]
  479.         set ins [lrange $ins 2 end]
  480.         switch -- $type {
  481.         "submenu" {
  482.             lappend msubs [lindex $ins 0]
  483.             # 'ins' may be just a menu name, or also contain various
  484.             # additional flags (-p proc etc)
  485.             set ins [list [concat Menu -n $ins [list {}]]]
  486.         }
  487.         }
  488.         switch -- [lindex $where 0] {
  489.         "replace" {
  490.             set old [lindex $where 1]
  491.             if {[set ix [eval llindex ma $old]] != -1} {
  492.             set ma [eval [list lreplace $ma $ix [expr {$ix -1 + [llength $old]}]] $ins]
  493.             } else {
  494.             alertnote "Bad menu::replacement registered '$old'"
  495.             }
  496.             
  497.         }
  498.         "end" {
  499.             eval lappend ma $ins
  500.         }
  501.         default {
  502.             if {![is::UnsignedInteger $where]} {
  503.             if {[set pos [lsearch -exact $ma $where]] != -1} {
  504.                 set where $pos
  505.             } else {
  506.                 alertnote "The string '$where' has not be found \
  507.                        in menu '$name'. '$ins' will be put at \
  508.                        the end of this menu"
  509.                 set where [llength $ma]
  510.             }
  511.             }
  512.             set ma [eval linsert [list $ma] $where $ins]
  513.         }
  514.         }
  515.     }
  516.     }
  517.     # These two lines removed due to some conflicts
  518.     #    regsub -all {"?\(-"?([ \t\r\n]+"?\(-"?)+} $ma "(-" ma
  519.     #    regsub -all {(^[ \t\r\n]*"?\(-"?|"?\(-"?[ \t\r\n]*$)} $ma "" ma
  520.  
  521.     # build the menu
  522.     set name [list -n $name]
  523.     if {[info exists theotherflags]} {
  524.     set name [concat $theotherflags $name]
  525.     }
  526.     if {[info tclversion] >= 8.0} {
  527.     lappend name -h [menu::helpText [lindex $name end]]
  528.     }
  529.     if {[info exists mproc]} {
  530.     if {$mproc != ""} {
  531.         eval Menu $name -p $mproc [list $ma]
  532.     } else {
  533.         eval Menu $name [list $ma]
  534.     }
  535.     } else {
  536.     eval Menu $name -p menu::generalProc [list $ma]
  537.     }
  538.     menu::postEval $token
  539.     if {[info exists msubs]} {
  540.     return $msubs
  541.     }
  542.     return ""
  543. }
  544.  
  545. proc menu::helpText {name} {
  546.     global winMenu
  547.     switch -- $name {
  548.     Config {
  549.         return [list "Config menu\r\rUse this menu to view and adjust\
  550.           your current preferences settings."]
  551.     }
  552.     Text {
  553.         return [list "Text menu\r\rUse this menu to manipulate lines,\
  554.           paragraphs or larger blocks of text.|Text menu\r\rIt is disabled\
  555.           because no windows are currently open."]
  556.     }
  557.     Utils {
  558.         return [list "Utils menu\r\rThis menu contains miscellaneous\
  559.           operations such as pairwise window comparison, spell-checking,\
  560.           plus access to various command-line 'Shells'."]
  561.     }
  562.     Search {
  563.         return [list "Search menu\r\rUse this menu to perform sophisticated\
  564.           find or replace operations on the contents of single or\
  565.           multiple windows or files."]
  566.     }
  567.     Edit {
  568.         return [list "Edit menu\r\rUse this menu to perform the standard\
  569.           cut, copy, paste operations, and to carry out other minor\
  570.           textual manipulations."]
  571.     }
  572.     File {
  573.         return [list "File menu\r\rUse this menu to open new windows,\
  574.           save or print existing windows, access recently used files,\
  575.           and revert windows to previously saved versions."]
  576.     }
  577.     default {
  578.         if {$name == $winMenu} {
  579.         return [list "Windows menu\r\rUse this menu to choose between\
  580.           open windows, and to adjust the shape or arrangement\
  581.           of existing windows.|Windows menu\r\rIt is disabled\
  582.           because no windows are currently open."]
  583.         } else {
  584.         global index::help
  585.         if {[info exists index::help($name)]} {
  586.             return [list [set index::help($name)]]
  587.         } else {
  588.             return [list "This is the $name menu"]
  589.         }
  590.         }
  591.     }
  592.     }
  593. }
  594.  
  595. proc menu::postEval {name} {
  596.     global menu::posteval
  597.     if {[info exists menu::posteval($name)]} {
  598.     catch {uplevel \#0 [set menu::posteval($name)]}
  599.     }
  600. }
  601.  
  602. proc menu::replaceRebuild {name title} {
  603.     global $name alpha::noMenusYet menu::toplevels
  604.     set bar [menu::inserted [set $name]]
  605.     if {$bar} {removeMenu [set $name]}
  606.     set $name $title
  607.     if {![info exists alpha::noMenusYet]} {
  608.     menu::buildSome $name
  609.     if {$bar} {insertMenu [set $name]}
  610.     }
  611. }
  612.  
  613. proc menu::packagesBuild {} {
  614.     global alpha::package_menus package::prefs
  615.     if {[info exists package::prefs]} {
  616.     lappend ma [menu::itemWithIcon "packagePreferences" 84] 
  617.     foreach pkg ${package::prefs} {
  618.         lappend ma "${pkg}Prefs…"
  619.     }
  620.     }
  621.     lappend ma "miscellaneousPackages…" "\(-" "(-)"
  622.     lappend ma "describeAPackage…" "readHelpForAPackage…" \
  623.       "uninstallSomePackages…" \
  624.       "(-" "rebuildPackageIndices"
  625.  
  626.     # removed in 7.4
  627.     # {Menu -m -n internetUpdates -p package::menuProc {}} 
  628.  
  629.     return [list build $ma menu::packagesProc internetUpdates]
  630. }
  631.  
  632. proc menu::packagesProc {menu item} {
  633.     global package::prefs alpha::prefs
  634.     if {[regexp "(.*)Prefs" $item d pkg]} {
  635.     if {[lcontains package::prefs $pkg]} {
  636.         if {[info exists alpha::prefs($pkg)]} {
  637.         dialog::pkg_options [set alpha::prefs($pkg)] \
  638.           "Preferences for the '[quote::Prettify $pkg]' package"
  639.         } else {
  640.         dialog::pkg_options $pkg
  641.         }
  642.         return
  643.     }
  644.     }
  645.     switch -- $item {
  646.     "miscellaneousPackages" {
  647.         return [dialog::preferences $menu Packages]
  648.     }
  649.     "describeAPackage" -
  650.     "Describe A Package" {
  651.         set pkg [dialog::optionMenu "Describe which package?" \
  652.           [lsort -ignore [alpha::package names]]]
  653.         package::describe $pkg
  654.     }
  655.     "readHelpForAPackage" -
  656.     "Read Help For A Package" {
  657.         set pkg [dialog::optionMenu "Read help for which package?" \
  658.           [lsort -ignore [alpha::package names]]]
  659.         package::helpFile $pkg
  660.     }
  661.     "uninstallSomePackages" -
  662.     "Uninstall Some Packages" {
  663.         package::uninstall
  664.     }
  665.     "rebuildPackageIndex" {
  666.         alpha::rebuildPackageIndices
  667.     }
  668.     "packagePreferences" {
  669.         global::allPackages
  670.         #alertnote "Select a package from the group below in the menu to\
  671.         #edit its preferences."
  672.     }
  673.     default {
  674.         menu::generalProc global $item
  675.     }
  676.     }
  677. }
  678.  
  679.  
  680. proc menu::menuPackages {menu m} {
  681.     if {[package::helpOrDescribe $m]} {
  682.     return
  683.     }
  684.     # toggle global existence of '$m' menu
  685.     global global::menus modifiedVars
  686.     if {[set idx [lsearch  ${global::menus} $m]] == -1} {
  687.     lappend global::menus $m
  688.     global $m
  689.     catch $m
  690.     insertMenu [set    $m]
  691.     markMenuItem packageMenus $m 1
  692.     } else {
  693.     set global::menus [lreplace ${global::menus} $idx $idx]
  694.     global $m
  695.     catch "removeMenu [set $m]"
  696.     markMenuItem packageMenus $m 0
  697.     }
  698.     lappend modifiedVars global::menus
  699. }
  700.  
  701. if {[info tclversion] < 8.0} {
  702.     proc menu::modeBuild {} {
  703.     set ma [list "menus…" "/p<Bfeatures…" "/ppreferences…" "editPrefsFile" \
  704.       "loadPrefsFile" "describeMode" "(-" "/m<UchangeMode…"]
  705.     return [list build $ma mode::menuProc "" "Mode Prefs"]
  706.     }
  707. } else {
  708.     proc menu::modeBuild {} {
  709.     global mode
  710.     set ma [list "menus…" "/p<Bfeatures…" "/ppreferences…" "editPrefsFile" \
  711.       "loadPrefsFile" "describeMode" "(-" "/m<UchangeMode…"]
  712.     if {$mode != ""} {
  713.         return [list build $ma mode::menuProc "" "${mode} Mode Prefs"]
  714.     } else {
  715.         return [list build $ma mode::menuProc "" "Mode Prefs"]
  716.     }
  717.     }
  718. }
  719.  
  720. proc menu::preferencesBuild {} {
  721.     global flagPrefs
  722.     
  723.     set ma [list "Menus…" "/p<U<BFeatures…" "/p<USuffix Mappings…" \
  724.       "Save Preferences Now" "Edit Prefs File" "(-" \
  725.       [menu::itemWithIcon "Interface Preferences" 84]]
  726.     lappend ma Appearance Completions Electrics Text Tiling Window "(-" \
  727.       [menu::itemWithIcon "Input-Output Preferences" 84]
  728.     lappend ma Backups Files Printer Tags WWW "(-" \
  729.       [menu::itemWithIcon "System Preferences" 84]
  730.     eval lunion ma [lsort [lremove [array names flagPrefs] Packages]]
  731.     return [list build $ma {dialog::preferences -m}]
  732. }
  733.  
  734. proc menu::removeFrom {name args} {
  735.     global menu::additions alpha::noMenusYet
  736.     if {[info exists menu::additions($name)]} {
  737.     if {[set i [lsearch -exact [set menu::additions($name)] $args]] != -1} {
  738.         set menu::additions($name) [lreplace [set menu::additions($name)] $i $i]
  739.         if {![info exists alpha::noMenusYet]} {
  740.         # we were called after start-up; build the menu now
  741.         menu::buildSome $name
  742.         } else {
  743.         hook::register startupHook "menu::buildSome [list $name]"
  744.         }
  745.     }
  746.     }
  747. }
  748.  
  749. proc menu::replaceWith {name current type args} {
  750.     global menu::additions alpha::noMenusYet
  751.     if {![info exists menu::additions($name)]} {
  752.     lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  753.     } else {
  754.     set add 1
  755.     set j 0
  756.     foreach i [set menu::additions($name)] {
  757.         if {[lrange $i 0 1] == [list $type [list replace $current]]} {
  758.         if {[lindex $i 1] != $args} {
  759.             set add 0
  760.             set menu::additions($name) \
  761.               [lreplace [set menu::additions($name)] $j $j \
  762.               [concat [list $type [list replace $current]] $args]]
  763.             break
  764.         } else {
  765.             # no change
  766.             return
  767.         }
  768.         }
  769.         incr j
  770.     }
  771.     if {$add} {
  772.         lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  773.     }
  774.     }
  775.     if {![info exists alpha::noMenusYet]} {
  776.     # we were called after start-up; build the menu now
  777.     menu::buildSome $name
  778.     } else {
  779.     hook::register startupHook "menu::buildSome [list $name]"
  780.     }
  781. }
  782.  
  783. proc menu::itemWithIcon {name icon} {
  784.     return "/\x1e${name}^[text::Ascii $icon 1]"
  785. }
  786.  
  787. proc menu::fileProc {menu item} {
  788.     switch -- $item {
  789.     "open" {
  790.         findFile
  791.     }
  792.     "close" {
  793.         killWindow
  794.     }
  795.     default {
  796.         uplevel 1 [list menu::generalProc file $item]
  797.     }
  798.     }
  799. }
  800.  
  801. ## 
  802.  # -------------------------------------------------------------------------
  803.  # 
  804.  # "menu::generalProc" --
  805.  # 
  806.  #  If either 'item' or 'menu::item' exists, call it.  Else try and
  807.  #  autoload 'item', if that fails try and autoload 'menu::item'
  808.  # -------------------------------------------------------------------------
  809.  ##
  810. if {[info tclversion] < 8.0} {
  811.     proc menu::generalProc {menu item {lower 1}} {
  812.     if {$lower} {set menu [string tolower $menu]}
  813.     if {[info commands ${menu}::${item}] != ""} {
  814.         uplevel \#0 ${menu}::$item
  815.     } elseif {[info commands $item] != ""} {
  816.         uplevel \#0 $item
  817.     } elseif {[auto_load ${menu}::$item]} {
  818.         uplevel \#0 ${menu}::$item
  819.     } else {
  820.         uplevel \#0 $item
  821.     }
  822.     }
  823. } else {
  824.     proc menu::generalProc {menu item {lower 1}} {
  825.     if {$lower} {set menu [string tolower $menu]}
  826.     if {[info commands ::${menu}::${item}] != ""} {
  827.         uplevel \#0 ::${menu}::$item
  828.     } elseif {[info commands $item] != ""} {
  829.         uplevel \#0 $item
  830.     } elseif {[auto_load ::${menu}::$item]} {
  831.         uplevel \#0 ::${menu}::$item
  832.     } else {
  833.         uplevel \#0 $item
  834.     }
  835.     }
  836. }
  837.  
  838. proc menu::globalProc {menu item} {
  839.     menu::generalProc global $item
  840. }
  841.  
  842. proc menu::winProc {menu name} {
  843.     global winNameToNum
  844.  
  845.     set nms [array names winNameToNum]
  846.  
  847.     if {[lsearch -glob $nms "*[quote::Find $name]"] < 0} {
  848.         $name
  849.         return
  850.     }
  851.  
  852.     foreach nm $nms {
  853.         if {[string match *[quote::Find $name] $nm] == "1"}  {
  854.             bringToFront $name
  855.             if {[icon -q]} { icon -f $name -o }
  856.             return
  857.         }
  858.     }
  859.     return "normal"
  860. }
  861.  
  862.  
  863. ## 
  864.  # proc namedClipMenuProc {menu item} {
  865.  #     switch $item {
  866.  #         "copy"      "copyNamedClipboard"
  867.  #         "cut"       "cutNamedClipboard"
  868.  #         "paste"     "pasteNamedClipboard"
  869.  #     }
  870.  # }
  871.  ##
  872.  
  873. proc menu::colorProc {menu item} {
  874.     global colorInds modifiedArrVars
  875.     if {[info exists colorInds($item)]} {
  876.     set color [eval [list colorTriple "New \"$item\":"] $colorInds($item)]
  877.     } else {
  878.     switch -- $item {
  879.         foreground    { set inds "0 0 0" }
  880.         background    { set inds "65535 65535 65535" }
  881.         blue        { set inds "0 0 65535" }
  882.         cyan        { set inds "61404 11464 34250" }
  883.         green        { set inds "1151 33551 8297" }
  884.         magenta        { set inds "44790 1591 51333" }
  885.         red            { set inds "65535 0 0" }
  886.         white        { set inds "65535 65535 65535" }
  887.         yellow        { set inds "61834 64156 12512" }
  888.         default        { set inds "65535 65535 65535" }
  889.     }
  890.     set color [eval [list colorTriple "New \"$item\":"] $inds]
  891.     }
  892.     eval setRGB $item $color
  893.     
  894.     set colorInds($item) $color
  895.     alpha::makeColourList
  896.     lappend modifiedArrVars colorInds
  897. }
  898.  
  899. proc alpha::makeColourList {} {
  900.     global alpha::colors colorInds alpha::basiccolors
  901.     # Set up color indices
  902.     foreach ind [array names colorInds] {
  903.     eval setRGB $ind $colorInds($ind)
  904.     }
  905.     set alpha::basiccolors {none blue cyan green magenta red white yellow}
  906.     set alpha::colors ${alpha::basiccolors}
  907.     foreach c {color_9 color_10 color_11 color_12 color_13 color_14 color_15} {
  908.     if {[info exists colorInds($c)]} {lappend alpha::colors $c}
  909.     }
  910. }
  911.     
  912. namespace eval icon {}
  913. namespace eval file {}
  914.  
  915. proc icon::FromID {ID} {
  916.     return "^[text::Ascii [expr {$ID - 0x1D0}] 1]"
  917. }
  918.  
  919. proc icon::FromSig {sig} {
  920.     global alpha::_icons
  921.     if {[set p [lsearch -glob ${alpha::_icons} "[quote::Find ${sig}] *"]] != -1} {
  922.     set p [lindex ${alpha::_icons} $p]
  923.     return [lindex $p 2]
  924.     } else {
  925.     return ""
  926.     }
  927. }
  928.  
  929. proc icon::MenuFromSig {sig} {
  930.     global alpha::_icons
  931.     if {[set p [lsearch -glob ${alpha::_icons} "[quote::Find ${sig}] *"]] != -1} {
  932.     set char [expr {[lindex [lindex ${alpha::_icons} $p] 2] -208}]
  933.     if {$char < 1 || $char > 256} { return "" }
  934.     return "^[text::Ascii $char 1]"
  935.     } else {
  936.     return ""
  937.     }
  938. }
  939.  
  940. proc menu::fileUtils {menu item} {
  941.     if {[lsearch -exact {"insertPathName" "insertFile" "fileRemove" "fileInfo" "wordCount" "textToAlpha"} $item] != -1} {return [$item]}
  942.     switch -- $menu {
  943.     "moreUtils" {
  944.         file::Utils::$item
  945.     }
  946.     default {
  947.         file::$item
  948.     }
  949.     }
  950. }
  951.  
  952. proc menu::winTileProc {menu item} {
  953.     win$item
  954. }
  955.  
  956. ## 
  957.  # -------------------------------------------------------------------------
  958.  # 
  959.  #    "menu::buildHierarchy" --
  960.  # 
  961.  #  Given a list of folders, 'menu::buildHierarchy' returns a hierarchical
  962.  #  menu based on the files and subfolders in each of these folders. 
  963.  #  Pathnames are optionally stored in a global array given by the argument
  964.  #  'filePaths'.  The path's index in this array is formed by concatenating
  965.  #  the submenu name and the filename, allowing the pathname to be
  966.  #  retrieved by the procedure 'proc' when the menu item is selected.
  967.  # 
  968.  #  The search may be restricted to files with specific extensions, or
  969.  #  files matching a certain pattern.  A search depth may also be given,
  970.  #  with three levels of subfolders assumed by default.
  971.  # 
  972.  #  See MacPerl.tcl or latexMenu.tcl for examples.
  973.  # 
  974.  #  (originally written by Tom Pollard, with modifications by Vince Darley
  975.  #  and Tom Scavo)
  976.  # 
  977.  # --Version--Author------------------Changes-------------------------------
  978.  #      1.0      Tom Pollard                    original
  979.  #      2.0      <vince@santafe.edu> multiple extensions, optional paths
  980.  #      2.1      Tom Scavo                        multiple folders
  981.  #      2.2      <vince@santafe.edu> pattern matching as well as exts
  982.  #      2.3      <vince@santafe.edu> handles unique menu-names and does text only
  983.  #      2.4      <jl@theophys.kth.se>    now also handles patterns like "*.{a,b}"
  984.  #      2.5      <vince@santafe.edu> better glob, non-dup dir handling
  985.  # -------------------------------------------------------------------------
  986.  ##
  987. proc menu::buildHierarchy {folders name proc {filePaths {}} {exts *} {depth 3} {fset {}}} {
  988.     global filesetmodeVars file::separator
  989.     if { $filePaths != "" } {
  990.     global $filePaths
  991.     }
  992.     if {[llength $exts] > 1} {
  993.     regsub -all {\.} $exts "" exts
  994.     set exts "*.{[join $exts ,]}"
  995.     } elseif {[string match ".*" $exts] && ![string match {*\**} $exts]} {set exts "*$exts"}
  996.     incr depth -1
  997.     set overallMenu {}
  998.     foreach folder $folders {
  999.     if {[file exists $folder]} {
  1000.         if {![file isdirectory $folder]} {
  1001.         set folder "[file dirname $folder]${file::separator}"
  1002.         }
  1003.         if {![regexp -- "${file::separator}$" $folder]} {
  1004.         set folder "$folder${file::separator}"
  1005.         }
  1006.         if {$name == 0} {
  1007.         set name [file tail [file dirname ${folder}dummy]]
  1008.         }
  1009.         # if it's a fileset, we register _before_ recursing
  1010.         if { $fset != "" } {
  1011.         set mname [filesetMenu::registerName $fset $name $proc]
  1012.         } else {
  1013.         set mname $name
  1014.         }
  1015.         set menu {}
  1016.         set subfolders [glob -nocomplain -types d -path $folder *]
  1017.         if {$filesetmodeVars(includeNonTextFiles)} {
  1018.         set filenames [glob -nocomplain -path $folder -- $exts]
  1019.         } else {
  1020.         set filenames [glob -types TEXT -nocomplain -path $folder $exts]
  1021.         }
  1022.         set last {}
  1023.         # Note that the list of filenames may also contain some/all
  1024.         # subfolders (if they matched the glob expression), hence
  1025.         # we must be sure not to add them twice.
  1026.         foreach m [lsort -ignore [concat $subfolders $filenames]] {
  1027.         if {[file isfile $m]} {
  1028.             set fname [file tail $m]
  1029.             if {([info tclversion] < 8.0) && ([string index $fname 0] == "-")} {
  1030.             set fname " $fname"
  1031.             }
  1032.             lappend menu "${fname}&"
  1033.             if {$filePaths != ""} {
  1034.             set ${filePaths}([file join $name $fname]) $m
  1035.             }
  1036.         } elseif {$depth > 0 && ($m != $last)} {
  1037.             set last $m
  1038.             set subM [menu::buildHierarchy [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  1039.             if {[llength $subM]} { 
  1040.             lappend menu $subM 
  1041.             set first 0
  1042.             }
  1043.         }
  1044.         }
  1045.         if {[llength $menu]} {
  1046.         set overallMenu [concat $overallMenu $menu]
  1047.         }
  1048.     } else {
  1049.         beep
  1050.         alertnote "menu::buildHierarchy:  Folder $folder does not exist!"
  1051.     }
  1052.     }
  1053.     
  1054.     if {[llength $overallMenu]} {
  1055.     if { [string length $proc] > 1 } {
  1056.         set pproc [list -p $proc]
  1057.     } else {
  1058.         set pproc [list]
  1059.     }    
  1060.     if { $fset != "" } {
  1061.         if {[string length $proc] > 1} { set pproc [list -p filesetMenu::subProc] }
  1062.     }     
  1063.     return [concat [list Menu -m -n] [list $mname] $pproc [list $overallMenu]]
  1064.     } else {
  1065.     return [list]
  1066.     }
  1067. }
  1068.  
  1069. # in case we've done something odd elsewhere
  1070. ensureset filesetmodeVars(includeNonTextFiles) 0
  1071.  
  1072. proc menu::reinterpretOldMenu {args} {
  1073.     set ma [lindex $args end]
  1074.     set args [lreplace $args end end]
  1075.     getOpts {-n -M -p}
  1076.     if {[info exists opts(-p)]} {
  1077.     lappend proc $opts(-p)
  1078.     } else {
  1079.     lappend proc "-1"
  1080.     }
  1081.     if {[info exists opts(-M)]} { lappend proc -M $opts(-m) }
  1082.     if {[info exists opts(-m)]} { lappend proc -m }
  1083.     menu::buildOne $opts(-n) build $ma $proc
  1084. }
  1085.  
  1086.